home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / vsc92nov.zip / misc-prim.c < prev    next >
C/C++ Source or Header  |  1992-11-02  |  5KB  |  256 lines
  1. /*
  2.  * misc-prim.c -- Implementation of miscellaneous Scheme primitives
  3.  *
  4.  * (C) m.b (Matthias Blume), Mon May 18 15:23:56 MET DST 1992, HUB/Ger
  5.  *         Humboldt-University of Berlin, Germany
  6.  */
  7.  
  8. # ident "@(#)misc-prim.c    (C) M.Blume, Humboldt-Uni Berlin, 1.7"
  9.  
  10. # include <stdio.h>
  11. # include <string.h>
  12. # include <stdlib.h>
  13.  
  14. # include "storage.h"
  15. # include "Cont.h"
  16. # include "Number.h"
  17. # include "String.h"
  18. # include "Boolean.h"
  19. # include "Code.h"
  20. # include "Primitive.h"
  21. # include "type.h"
  22. # include "tmpstring.h"
  23. # include "mode.h"
  24. # include "except.h"
  25.  
  26. # include "builtins.tab"
  27.  
  28. /* Primitive No. 0: */
  29. void ScmVMTrapC (void)
  30. {
  31.   reset ("VM Trap");
  32. }
  33.  
  34. void ScmVMTrap (unsigned short cnt)
  35. {
  36.   ScmVMTrapC ();
  37. }
  38.  
  39. /* Primitive No. 1: */
  40. void ScmVMErrorC (void)
  41. {
  42.   reset ("tried to call error continuation");
  43. }
  44.  
  45. void ScmVMError (unsigned short argcnt)
  46. {
  47.   ScmVMErrorC ();
  48. }
  49.  
  50. /* Primitive No. 2: */
  51. void ScmVMGCStrategyC (void)
  52. {
  53.   void *tmp = ScmPeek ();
  54.   long bound;
  55.  
  56.   if (tmp == &ScmFalse)
  57.     reset ("user gc-strategy gives up");
  58.   if (ScmTypeOf (tmp) == ScmType (ExactNumber)) {
  59.     bound = ScmNumberToInt (tmp);
  60.     gc_set_min_heap_size (bound);
  61.   }
  62.   ScmRevertToFatherContinuation (1);
  63.   (void) ScmPop ();
  64. }
  65.  
  66. void ScmVMGCStrategy (unsigned short argcnt)
  67. {
  68.   fatal ("internal error (ScmVMGCStrategy called)");
  69. }
  70.  
  71. /* Primitive No. 3: */
  72. void ScmVMInterruptC (void)
  73. {
  74.   ScmRevertToFatherContinuation (1);
  75.   (void) ScmPop ();
  76. }
  77.  
  78. void ScmVMInterrupt (unsigned short argcnt)
  79. {
  80.   fatal ("internal error (ScmVMInterrupt called)");
  81. }
  82.  
  83. void ScmPrimitiveQuit (unsigned short argcnt)
  84. {
  85.   int stat = EXIT_SUCCESS;
  86.   if (argcnt == 1)
  87.     stat = ScmNumberToInt (ScmPop ());
  88.   else if (argcnt > 1)
  89.     error ("wrong argcnt (%u) for primitive procedure quit", (unsigned) argcnt);
  90.  
  91.   exit (stat);
  92. }
  93.  
  94. # define DUMP_FILENAME_LEN 256
  95.  
  96. /*ARGSUSED*/
  97. void ScmPrimitiveDump (unsigned short argcnt)
  98. {
  99.   void *tmp;
  100.   ScmString *string;
  101.   FILE *fp;
  102.   char *filename;
  103.  
  104.   tmp = ScmPop ();
  105.   if (ScmTypeOf (tmp) != ScmType (String))
  106.     error ("wrong argument type for primitive procedure dump: %w", tmp);
  107.   string = tmp;
  108.   filename = tmpstring (string->array, string->length);
  109.   if ((fp = fopen (filename, "wb")) == NULL)
  110.     error ("cannot open file \"%s\" for dump", filename);
  111.   ScmPush (&ScmFalse);
  112.   ScmPushContinuation (1);
  113.   dump_storage (fp);
  114.   fclose (fp);
  115.   ScmCC = *ScmCC.father;
  116.   ScmSetTop (&ScmTrue);
  117. }
  118.  
  119. /*ARGSUSED*/
  120. void ScmPrimitiveExecuteAsm (unsigned short argcnt)
  121. {
  122.   void *proc = ScmAsm (ScmPeek ());
  123.  
  124.   ScmSetTop (proc);
  125.   ScmCC.call_again = 1;
  126. }
  127.  
  128. /*ARGSUSED*/
  129. void ScmPrimitiveDefineAsm (unsigned short argcnt)
  130. {
  131.   (void) ScmAsmDcl (ScmPeek ());
  132.   ScmSetTop (&ScmTrue);
  133. }
  134.  
  135. /*ARGSUSED*/
  136. void ScmPrimitiveSystem (unsigned short argcnt)
  137. {
  138.   ScmString *string;
  139.   int status;
  140.  
  141.   string = ScmPeek ();
  142.   if (ScmTypeOf (string) != ScmType (String))
  143.     error ("bad arg to primitive procedure system: %w", string);
  144.   status = system (tmpstring (string->array, string->length));
  145.   ScmSetTop (status == EXIT_SUCCESS ? &ScmTrue : &ScmFalse);
  146. }
  147.  
  148. static void call_with_mode (int mode_id)
  149. {
  150.   void *mode;
  151.  
  152.   mode = ScmPop ();
  153.   ScmPushPrimitiveContinuation (mode, 1);
  154.   ScmSetMode (mode_id, ScmCC.environ);
  155.   ScmPush (ScmCPop (ScmCC.father));
  156.   ScmCC.call_again = 1;
  157. }
  158.  
  159. /*ARGSUSED*/
  160. void ScmPrimWithErrorHandler (unsigned short argcnt)
  161. {
  162.   call_with_mode (SCM_ERROR_HANDLER_MODE);
  163. }
  164.  
  165. /*ARGSUSED*/
  166. void ScmPrimWithGCStrategy (unsigned short argcnt)
  167. {
  168.   call_with_mode (SCM_GC_STRATEGY_MODE);
  169. }
  170.  
  171. /*ARGSUSED*/
  172. void ScmPrimWithIntHandler (unsigned short argcnt)
  173. {
  174.   call_with_mode (SCM_INTERRUPT_MODE);
  175. }
  176.  
  177. void ScmPrimWithSomethingC (void)
  178. {
  179.   ScmRevertToFatherContinuation (1);
  180. }
  181.  
  182. /*ARGSUSED*/
  183. void ScmPrimitiveInspect (unsigned short argcnt)
  184. {
  185.   ScmContinuation *cont;
  186.   ScmVector *vect;
  187.   void *tmp;
  188.   long n;
  189.   unsigned long nxt_stat;
  190.   unsigned short stack_top, call_again;
  191.  
  192.   cont = ScmPop ();
  193.   tmp = ScmPeek ();
  194.   ScmSetTop (cont);
  195.   n = ScmNumberToInt (tmp);
  196.   cont = ScmPeek ();
  197.   while (n-- > 0 && ScmTypeOf (cont) == ScmType (Continuation))
  198.     cont = cont->father;
  199.   if (ScmTypeOf (cont) != ScmType (Continuation))
  200.     ScmSetTop (&ScmFalse);
  201.   else {
  202.     ScmSetTop (cont);
  203.     nxt_stat = cont->nxt_stat;
  204.     stack_top = cont->stack_top;
  205.     call_again = cont->call_again;
  206.     vect = NewScmVector (8);
  207.     cont = ScmPeek ();
  208.     vect->array [0] =
  209.       (cont->code == NULL) ? &ScmFalse : cont->code->proc_name;
  210.     vect->array [2] = cont->environ;
  211.     vect->array [3] = cont->constants;
  212.     vect->array [4] = cont->stack;
  213.     vect->array [6] = cont->shared ? &ScmTrue : &ScmFalse;
  214.     ScmSetTop (vect);
  215.     tmp = (cont->code == NULL)
  216.         ? GetScmPrimitive (nxt_stat)
  217.         : ScmIntToExactNumber (nxt_stat);
  218.     vect = ScmPeek ();
  219.     vect->array [1] = tmp;
  220.     tmp = ScmIntToExactNumber (stack_top);
  221.     vect = ScmPeek ();
  222.     vect->array [5] = tmp;
  223.     tmp = ScmIntToExactNumber (call_again);
  224.     vect = ScmPeek ();
  225.     vect->array [7] = tmp;
  226.   }
  227. }
  228.  
  229. /*ARGSUSED*/
  230. void ScmPrimitiveError (unsigned short argcnt)
  231. {
  232.   error ("%d", ScmPeek ());
  233. }
  234.  
  235. # if (1000 < CLOCKS_PER_SEC)
  236. # define CLK2MS(clk) ((clk)/(CLOCKS_PER_SEC/1000))
  237. # else
  238. # define CLK2MS(clk) (((clk)*1000)/CLOCKS_PER_SEC)
  239. # endif
  240.  
  241. /*ARGSUSED*/
  242. void ScmPrimitiveClock (unsigned short argcnt)
  243. {
  244.   void *tmp = ScmIntToExactNumber ((long) CLK2MS (clock ()));
  245.  
  246.   ScmPush (tmp);
  247. }
  248.  
  249. /*ARGSUSED*/
  250. void ScmPrimitiveGcClock (unsigned short argcnt)
  251. {
  252.   void *tmp = ScmIntToExactNumber ((long) CLK2MS (total_gc_clock ()));
  253.  
  254.   ScmPush (tmp);
  255. }
  256.